Celestin Apprentice 7/Apprentice-Release7.iso/Source Code/Pascal/Snippets/PNL Libraries/MyListWindowHeaders.p

Text File | 1997-03-18 | 8.2 KB | 356 lines | [TEXT/CWIE]

unit MyListWindowHeaders;

interface

    uses
        Types, Quickdraw, Lists, QuickdrawText, Events,
         MyListWindow;

    const
        columns_max = 7;
        columns1 = columns_max + 1;

    type
        OffsetsArray = array[1..columns1] of integer;
        StringsArray = array[1..columns_max] of Str255;

    type
        ListWindowHeadersObject = object(ListWindowObject)
                columns: integer;
                headers_strh_id: integer;
                sort_column: integer;
                off: OffsetsArray;
                gap, baseoff, headeroff: integer;
                aligns: array[boolean] of string[columns_max];
                do_header_clicks: boolean;
                procedure CreateList (font, size: integer; listitem: integer; ldefID: integer; hscroll: boolean);
                override;
                procedure LDEF (message: integer; select: boolean; var r: Rect; c: Cell; dataoffset, datalen: integer);
                override;
                procedure DrawHeader (r: Rect);
                override;
                procedure DoHeaderClick (r: Rect; where: Point; const er: EventRecord);
                override;
                procedure GetHeaderStrings (var ss: StringsArray);
                procedure Strings (index: integer; var ss: StringsArray);
                procedure GetStringRect (const r: Rect; col: integer; var ss: StringsArray; var ther: Rect; header: boolean);
                procedure DrawStrings (r: Rect; var ss: StringsArray; select, header: boolean; hilite: integer);
                procedure DrawEntry( index: integer; select: boolean; var r: Rect );
                procedure MaxStrings (var maxs: OffsetsArray; var ss: StringsArray);
                procedure GetMaxs (var maxs: OffsetsArray);
                procedure SetOffs;
                procedure GetResourceStrings (id: integer; var ss: StringsArray);

                function EditMenuEnabled: boolean;
                override;
                procedure SetEditMenuItem (item: integer);
                override;
                procedure DoEditMenu (item: integer);
                override;
                function CopySelectionToHandle: Handle;
            end;

implementation

    uses
        TextUtils, Scrap, Events, Memory,
        MyTypes, MyUtils, MyMenus, MyListManager, MyMemory;

    procedure ListWindowHeadersObject.GetResourceStrings (id: integer; var ss: StringsArray);
        var
            i: integer;
    begin
        for i := 1 to columns do begin
            GetIndString(ss[i], id, i);
        end;
    end;

    procedure ListWindowHeadersObject.GetHeaderStrings (var ss: StringsArray);
    begin
        GetResourceStrings( headers_strh_id, ss );
    end;

    procedure ListWindowHeadersObject.Strings (index: integer; var ss: StringsArray);
        var
            i: integer;
    begin
{$unused(index)}
        for i := 1 to columns do begin
            ss[i] := '???';
        end;
    end;

    procedure ListWindowHeadersObject.MaxStrings (var maxs: OffsetsArray; var ss: StringsArray);
        var
            i, sw: integer;
    begin
        for i := 1 to columns do begin
            sw := StringWidth(ss[i]);
            if sw > maxs[i] then begin
                maxs[i] := sw;
            end;
        end;
    end;

    procedure ListWindowHeadersObject.GetMaxs (var maxs: OffsetsArray);
        var
            i: integer;
            ss: StringsArray;
    begin
        SetPort(window);
        for i := 1 to columns do begin
            maxs[i] := 0;
        end;
        GetHeaderStrings(ss);
        MaxStrings(maxs, ss);
    end;

    procedure ListWindowHeadersObject.SetOffs;
        var
            i: integer;
            maxs: OffsetsArray;
    begin
        GetMaxs(maxs);
        off[1] := gap;
        for i := 1 to columns do begin
            off[i + 1] := off[i] + maxs[i] + gap;
        end;
        SetListWidth(off[columns + 1]);
    end;

    procedure ListWindowHeadersObject.GetStringRect (const r: Rect; col: integer; var ss: StringsArray; var ther: Rect; header: boolean);
        var
            sw: integer;
    begin
        sw := StringWidth(ss[col]);
        ther.top := r.top;
        ther.bottom := r.bottom;
        if header then begin
            ther.bottom := ther.bottom - 3;
        end;
        case aligns[header][col] of
            'L':  begin
                ther.left := r.left - list_offset + off[col];
            end;
            'R':  begin
                ther.left := r.left - list_offset + off[col + 1] - sw - gap;
            end;
            'C':  begin
                ther.left := r.left - list_offset + (off[col] + off[col + 1] - sw - gap) div 2;
            end;
        end;
        ther.right := ther.left + sw;
    end;

    procedure ListWindowHeadersObject.    DrawStrings (r: Rect; var ss: StringsArray; select, header: boolean; hilite: integer);
        var
            ps: PenState;
            i: integer;
            ir: Rect;
    begin
        SetPort(window);
        GetPenState(ps);
        PenNormal;
        EraseRect(r);

        for i := 1 to columns do begin
            GetStringRect(r, i, ss, ir, header);
            if header then begin
                MoveTo(ir.left, ir.bottom - headeroff);
            end else begin
                MoveTo(ir.left, ir.bottom - baseoff);
            end;
            if header and (hilite = i) then begin
                TextFace([underline]);
                DrawString(ss[i]);
                TextFace([]);
            end else begin
                DrawString(ss[i]);
            end;
        end;

        if select then begin
            HiliteInvertRect(r);
        end;

        SetPenState(ps);
    end;

    procedure ListWindowHeadersObject.DrawHeader (r: Rect);
        var
            ss: StringsArray;
    begin
        GetHeaderStrings(ss);
        DrawStrings(r, ss, false, true, sort_column);
        MoveTo(r.left,r.bottom-2);
        LineTo(r.right,r.bottom-2);
    end;

    procedure ListWindowHeadersObject.DoHeaderClick (r: Rect; where: Point; const er: EventRecord);
        var
            i, j: integer;
            ir: Rect;
            ss: StringsArray;
            on, newon: boolean;
    begin
{$unused(er)}
        if do_header_clicks then begin
            j := -1;
            GetHeaderStrings(ss);
            for i := 1 to columns do begin
                GetStringRect(r, i, ss, ir, true);
                if PtInRect(where, ir) then begin
                    j := i;
                    leave;
                end;
            end;
            if (j > 0) & (j <> sort_column) then begin
                InsetRect(ir, -1, 1);
                InvertRect(ir);
                on := true;
                while StillDown do begin
                    GetMouse(where);
                    newon := PtInRect(where, ir);
                    if newon <> on then begin
                        InvertRect(ir);
                        on := newon;
                    end;
                end;
                if on then begin
                    InvertRect(ir);
                    sort_column := j;
                    DrawStrings(r, ss, false, true, sort_column);
                end;
            end;
        end;
    end;

    procedure ListWindowHeadersObject.DrawEntry( index: integer; select: boolean; var r: Rect );
        var
            ss: StringsArray;
    begin
        Strings( index, ss );
        DrawStrings( r, ss, select, false, 0 );
    end;

    function ListWindowHeadersObject.EditMenuEnabled: boolean;
    begin
        EditMenuEnabled := LCount( list ) > 0;
    end;

    procedure ListWindowHeadersObject.SetEditMenuItem (item: integer);
    begin
        case item of
            EMcopy:  begin
                SetIDItemEnable(M_Edit, item, IsSelection);
            end;
            EMselectall:  begin
                SetIDItemEnable(M_Edit, item, (LCount( list ) > 0) & not LAllSelected( list ) );
            end;
            otherwise begin
                SetIDItemEnable(M_Edit, item, false);
            end;
        end;
    end;

    function ListWindowHeadersObject.CopySelectionToHandle: Handle;
        var
            data: Handle;
            c: Cell;
            count: integer;
            err, junk: OSErr;
            ss: StringsArray;
            size: longint;
            i: integer;
    begin
        c.h := 0;
        c.v := 0;
        junk := MNewHandle( data, 0 );
        count := 0;
        while LGetSelect(true, c, list) do begin
            Strings( c.v+1, ss );
            size := GetHandleSize( data );
            for i := 1 to columns do begin
                if i < columns then begin
                    ss[i] := ss[i] + tab;
                end else begin
                    ss[i] := ss[i] + cr;
                end;
                err := PtrAndHand(@ss[i][1], data, length(ss[i]));
                if err <> noErr then begin
                    leave;
                end;
            end;
            if err <> noErr then begin
                SetHandleSize( data, size );
            end;
            c.v := c.v + 1;
        end;
        CopySelectionToHandle := data;
    end;

    procedure ListWindowHeadersObject.DoEditMenu (item: integer);
        var
            loe: longint;
            data: Handle;
    begin
        case item of
            EMcopy:  begin
                data := CopySelectionToHandle;
                loe := ZeroScrap;
                HLock( data );
                loe := PutScrap( GetHandleSize( data ), 'TEXT', data^ );
                MDisposeHandle( data );
            end;
            EMselectall:  begin
                LSetAllSelections( list, true );
            end;
            otherwise begin
                { do nothing }
            end;
        end;
    end;

    procedure ListWindowHeadersObject.LDEF (message: integer; select: boolean; var r: Rect; c: Cell; dataoffset, datalen: integer);
        procedure LDClose;
        begin
        end;

        procedure LDDraw;
        begin
            DrawEntry( c.v + 1, select, r );
{            if datalen = 0 then begin
            end;}
        end;

    begin
{$unused(dataoffset, datalen)}
        case message of
            lInitMsg:
                ;
            lDrawMsg:
                LDDraw;
            lHiliteMsg:
                LDDraw;
            lCloseMsg:
                LDClose;
        end;
    end;

    procedure ListWindowHeadersObject.CreateList (font, size: integer; listitem: integer; ldefID: integer; hscroll: boolean);
        var
            fi: FontInfo;
    begin
        inherited CreateList(font, size, listitem, ldefID, hscroll);
        sort_column := -1;
        gap := 5;
        GetFontInfo(fi);
        baseoff := fi.leading + fi.descent;
        headeroff := baseoff;
        header_height := fi.ascent + fi.leading + fi.descent + 2;
        do_header_clicks := true;
        aligns[false] :='LLLLLLL';
        aligns[true] :='LLLLLLL';
    end;

end.